Programming Sound Cards/Programming Sound Cards.iso/sound_57/rm.pas

Pascal/Delphi Source File | 1995-01-01 | 39KB | 1,208 lines

{  Rowan McKenzie's personalised functions for Turbo Pascal 4  28/3/89}

Unit rm;

  {$v-}

  {************************************************************************}

Interface

Uses crt, graph, mousfunc, printer;


Const
  dialogstringlength = 100;
  clickboxstringlength = 100;

Type
  argtypes       = (_none, _boolean, _char, _integer, _real, _string);
  dialogentryp   = ^dialogentrytype;
  dialogentrytype = Record
                      next           : dialogentryp;
                      title          : String[dialogstringlength];
                      Case argtype   : argtypes Of
                        _none          : ();
                        _boolean : (booleanresult : Boolean);
                        _char : (charresult : Char);
                        _integer : (integerresult : Integer);
                        _real : (realresult     : Real;
                                decimalp       : Integer);
                        _string : (stringresult   : String[dialogstringlength];
                                  ssize : Byte; nulvalid : Boolean);
                    End;
  titletype      = (_text, _figure);
  polypointp     = ^polypoint;
  polypoint = Record
                x, y           : Integer;
              End;
  clickboxtypep  = ^clickboxtype;
  clickboxtype = Record
                   next           : clickboxtypep;
                   x, y           : Integer; {box top left corner position}
                   Case ttype     : titletype Of
                     _text : (title : String[clickboxstringlength]);
                     _figure : (numpoints : Word; polypoints : polypointp;
                                fill           : Boolean);
                 End;

Var exitsave   : Pointer;
  showerrormessage : Boolean;


Procedure heaperrorinit;

  { initialised head error pointer to custom procedure}

Function log(a : Real)      : Real;

  { calculates log base 10 of a}

Procedure fixcursor;

  { restores correct cursor for Herc card}

Procedure readinteger(Var num : Integer);

{ readlns an integer from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

Procedure readlongint(Var num : LongInt);

{ readlns a long integer from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

Procedure readreal(Var num : Real);

{ readlns a real from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

Procedure greadstring(Var s : String; fieldwidth : Integer);

  { readlns a string from kbd in graphics mode}

Procedure greadinteger(Var num : Integer);

{ readlns an integer from kbd in graphics mode. if enter or invalid entry is
  entered, leaves num unchanged}

Procedure greadlongint(Var num : LongInt);

{ readlns a long integer from kbd in graphics mode. if enter or invalid entry
  is entered, leaves num unchanged}

Procedure greadreal(Var num : Real);

{ readlns a real from kbd in graphics mode. if enter or invalid entry is
  entered, leaves num unchanged}

Procedure swapscreen;

  { change virtual graphics pages, saving current page to heap}

Procedure leavegraph;

  { return to text mode, but save screen on heap}

Procedure entergraph(graphmode : Integer);

  { return to graphics mode, restoring saved screen from heap}

Procedure screendump;

  { graphics hardware independant graphics screen dump}

Procedure add_dialogentry(Var dp, lastdialogentry,
                          dialogentryhead : dialogentryp);

  { appends dialog entry to list}

Procedure dialog_box(dialog : dialogentryp; bcolor, color : Integer;
                     continueprompt : Boolean);

{ draws arguments messages in dialog box, allows editing of fields,
  restores area under box}

Procedure dispose_dialog(Var dp : dialogentryp);

  { disposes of all entries in dialog list}

Procedure beep;

  { short beep on console }

Procedure selectcolor(color : Word);

  { calls setcolor with modified color value depending on available colors}

Procedure selectbcolor(color : Word);

Procedure selectfillstyle(pattern : Word; color : Word);

{ calls selectfillstyle with modified color value depending on available
  colors}

Procedure selectbfillstyle(pattern : Word; color : Word);

{ calls selectfillstyle with modified background color value depending on
  available colors}

Procedure fill_background(color, fillpattern, arcsize : Word);

  { fills background with color and rounds the corners}

Procedure panel(x, y : Integer; width, height, color : Word);

  { draws solid panel with center top at x,y, width by height}

Procedure add_clickboxentry(Var cp, lastclickbox, clickboxhead : clickboxtypep);

  { appends clickbox to list}

Procedure draw_clicklist(cp : clickboxtypep; x, y, bcolor, color : Integer);

  { draws list of click boxes at given offset}

Function click_selection(cp : clickboxtypep; x, y : Integer) : Integer;

  { tests whether mouse is over a click box and returns its number in the list}

Procedure dispose_clickboxlist(Var cp : clickboxtypep);

  { disposes of all entries in click box list}

Function continue_prompt(x, y, bcolor, color : Integer) : Char;

  { displays continue prompt and waits for button or key}

Procedure display_message(s : String; bcolor, color : Integer;
                          Var storagep : Pointer; show       : Boolean);

  { draws message in box at screen center (or restores screen if show=false)}



  {********************************************************************}

Implementation

Const
  screens        = 2;
  bigemptystring =
  '                                                                                                                       ';

Var scrnbufp   : Array[1..screens] Of Pointer;
                                  {points to graphics screen save areas}
  currentscreen  : Byte;          {virtual graphics screen currently active}
  firstget       : Array[1..screens] Of Boolean;
                                  {indicate first time screen is saved}
  firstput       : Array[1..screens] Of Boolean;
                                  {indicate first time screen is restored}
  i              : Integer;



  Function log(a : Real)      : Real;

    { calculates log base 10 of a}

  Begin
    log := 0.434294481*ln(a);
  End;


  Procedure fixcursor;

  Begin
    MemW[0:$460] := $0b0c;
  End;                            {fixcursor}


  {$f+}
  Procedure myexit; {$f-}

    { incase graphics mode, restore text screen before error message is given}

  Begin
    restorecrtmode;
    ExitProc := exitsave;
    If showerrormessage Then
      WriteLn('Exit due to internal error!');
  End;                            {myexit}


  {$f+} Function heapfunc(size : Word)   : Integer; {$f-}

    { called when heap error occurs}

  Begin
    heapfunc := 1;
    restorecrtmode;
    WriteLn;
    WriteLn;
    WriteLn('Insufficient memory - sorry.', ^g);
    WriteLn;
    Halt;
  End;                            {heapfunc}


  Procedure heaperrorinit;

    { initialised head error pointer to custom procedure}

  Begin
    HeapError := @heapfunc;
  End;                            {heaperrorinit}


  Procedure readinteger(Var num : Integer);

{ readlns an integer from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

  Var st         : String;
    code           : Integer;
    number         : LongInt;

  Begin
    ReadLn(st);
    If st <> '' Then
    Begin
      Val(st, number, code);
      If (code = 0) And (number >= -MaxInt) And (number <= MaxInt) Then
        num := number;
    End;
  End;                            {readinteger}


  Procedure readlongint(Var num : LongInt);

{ readlns a long integer from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

  Var st         : String;
    code           : Integer;
    number         : LongInt;

  Begin
    ReadLn(st);
    If st <> '' Then
    Begin
      Val(st, number, code);
      If code = 0 Then
        num := number;
    End;
  End;                            {readlongint}


  Procedure readreal(Var num : Real);

{ readlns a real from kbd. if enter or invalid entry is entered,
  leaves num unchanged}

  Var st         : String;
    code           : Integer;
    number         : Real;

  Begin
    ReadLn(st);
    If st <> '' Then
    Begin
      Val(st, number, code);
      If code = 0 Then
        num := number;
    End;
  End;                            {readreal}


  Procedure greadstring(Var s : String; fieldwidth : Integer);

    { readlns a string from kbd in graphics mode}

  Var c          : Char;
    colorinfo      : Word;

    Procedure backspace(c : Char);

      { backspaces cp over last char displayed (c)}

    Begin
      moverel(-textwidth(c), 0);
      setcolor(getpixel(getx+textwidth(' '), gety));
                                    {assume empty character on }
      outtext(c); {erase character} { right is background color}
      moverel(-textwidth(c), 0);
      setcolor(colorinfo);
    End;                          {backspace}

  Begin                           {greadstring}
    colorinfo := getcolor;
    s := '';
    Repeat
      outtext('_');               {provide cursor}
      c := readkey;
      backspace('_');
      Case c Of
        ' '..'~' : If Length(s) < fieldwidth Then
                   Begin
                     s := s+c;
                     outtext(s[Length(s)]);
                   End;
        #8, #$7f : If Length(s) > 0 Then {back space, del}
                   Begin
                     backspace(s[Length(s)]);
                     Delete(s, Length(s), 1);
                   End;
      End;                        {case}
    Until c = #13;
  End;                            {greadstring}


  Procedure greadinteger(Var num : Integer);

{ readlns an integer from kbd in graphics mode. if enter or invalid entry is
  entered, leaves num unchanged}

  Var st         : String;
    code           : Integer;
    number         : LongInt;

  Begin
    greadstring(st, 6);
    If st <> '' Then
    Begin
      Val(st, number, code);
      If (code = 0) And (number >= -MaxInt) And (number <= MaxInt) Then
        num := number;
    End;
  End;                            {greadinteger}


  Procedure greadlongint(Var num : LongInt);

{ readlns a long integer from kbd in graphics mode. if enter or invalid entry
  is entered, leaves num unchanged}

  Var st         : String;
    code           : Integer;
    number         : LongInt;

  Begin
    greadstring(st, 11);
    If st <> '' Then
    Begin
      Val(st, number, code);
      If code = 0 Then
        num := number;
    End;
  End;                            {greadlongint}


  Procedure greadreal(Var num : Real);

{ readlns a real from kbd in graphics mode. if enter or invalid entry is
  entered, leaves num unchanged}

  Var st         : String;
    code           : Integer;
    number         : Real;

  Begin
    greadstring(st, 20);
    If st <> '' Then
    Begin
      Val(st, number, code);
      If code = 0 Then
        num := number;
    End;
  End;                            {greadreal}


  Procedure swapscreen;

    { change virtual graphics pages, saving current page to heap}

  Begin
    If firstget[currentscreen] Then
    Begin
      GetMem(scrnbufp[currentscreen], imagesize(0, 0, getmaxx, getmaxy));
      firstget[currentscreen] := False;
    End;
    getimage(0, 0, getmaxx, getmaxy, scrnbufp[currentscreen]^);
    currentscreen := currentscreen Mod 2+1;
    If firstput[currentscreen] Then
    Begin
      firstput[currentscreen] := False;
      cleardevice;
    End
    Else
      putimage(0, 0, scrnbufp[currentscreen]^, normalput);
  End;                            {swapscreen}


  Procedure leavegraph;

    { return to text mode, but save screen on heap}

  Begin
    GetMem(scrnbufp[currentscreen], imagesize(0, 0, getmaxx, getmaxy));
    getimage(0, 0, getmaxx, getmaxy, scrnbufp[currentscreen]^);
    restorecrtmode;
  End;                            {leavegraph}


  Procedure entergraph(graphmode : Integer);

    { return to graphics mode, restoring saved screen from heap}

  Begin
    setgraphmode(graphmode);
    putimage(0, 0, scrnbufp[currentscreen]^, normalput);
    FreeMem(scrnbufp[currentscreen], imagesize(0, 0, getmaxx, getmaxy));
  End;                            {entergraph}


  Procedure screendump;

    { graphics hardware independant graphics screen dump}

  Var column, row, total, bit, value : Integer;

  Begin
    For row := 0 To (getmaxy Div 8)+1 Do
    Begin
      Write(lst, ^[ , 'A', #8);
      Write(lst, ^[ , 'L', Chr(Succ(getmaxx) Mod 256),
            Chr(Succ(getmaxx) Div 256));
      For column := 0 To getmaxx Do
      Begin
        total := 0;
        value := 128;
        For bit := 0 To 7 Do
        Begin
          If getpixel(column, row*8+bit) <> black Then
            total := total+value;
          value := value Div 2;
        End;
        Write(lst, Chr(total));
      End;
      Write(lst, #13, #10);
    End;
  End;                            {screendump}


  Procedure beep;

    { short beep on console }

  Begin
    sound(1200);
    delay(5);
    nosound;
  End;                            {beep}


  Procedure selectcolor(color : Word);

    { calls setcolor with modified color value depending on available colors}

  Begin
    If (getmaxcolor > 1) Or (color = black) Then
      setcolor(color)
    Else
      setcolor(getmaxcolor);
  End;                            {selectcolor}


  Procedure selectbcolor(color : Word);

    { calls setcolor with modified background color value depending
      on available colors}

  Begin
    If getmaxcolor > 1 Then
      setcolor(color)
    Else
      setcolor(black);
  End;                            {selectcolor}


  Procedure selectfillstyle(pattern : Word; color : Word);

{ calls selectfillstyle with modified color value depending on available
  colors}

  Begin
    If (getmaxcolor > 1) Or (color = black) Then
      setfillstyle(pattern, color)
    Else
      setfillstyle(pattern, getmaxcolor);
  End;                            {selectfillstyle}


  Procedure selectbfillstyle(pattern : Word; color : Word);

{ calls selectfillstyle with modified background color value depending
  on available colors}

  Begin
    If getmaxcolor > 1 Then
      setfillstyle(pattern, color)
    Else
      setfillstyle(pattern, black);
  End;                            {selectfillstyle}


  Procedure add_dialogentry(Var dp, lastdialogentry,
                            dialogentryhead : dialogentryp);

    { appends dialog entry to list}

  Begin                           {add_dialogentry}
    dp^.next := Nil;
    If dialogentryhead = Nil Then
      dialogentryhead := dp
    Else
      lastdialogentry^.next := dp;
    lastdialogentry := dp;
  End;                            {add_dialogentry}


  Procedure dialog_box(dialog : dialogentryp; bcolor, color : Integer;
                       continueprompt : Boolean);

{ draws arguments messages in dialog box, allows editing of fields,
  restores area under box}

  Const booleanfieldlength = 6;
    charfieldlength = 1;
    integerfieldlength = 6;
    realfieldlength = 20;

  Var i, leftedge, rightedge, yposition, maxstringlength, narguments,
    boxwidth, boxheight : Integer;
    dp             : dialogentryp;
    savep          : Pointer;
    str1           : String;
    c, cl          : Char;


    Function leftargument(dp : dialogentryp) : Integer;

      {  calculates where left edge of argument field is for given argument
         type}


    Begin                         {leftargument}
      Case dp^.argtype Of
        _boolean : leftargument := rightedge-
                   textwidth(Copy(bigemptystring, 1,
                                  booleanfieldlength+1));
        _char : leftargument := rightedge-
                textwidth(Copy(bigemptystring, 1,
                               charfieldlength+1));
        _integer : leftargument := rightedge-
                   textwidth(Copy(bigemptystring, 1,
                                  integerfieldlength+1));
        _real : leftargument := rightedge-
                textwidth(Copy(bigemptystring, 1,
                               realfieldlength+1));
        _string : leftargument := rightedge-
                  textwidth(Copy(bigemptystring, 1, dp^.ssize+1));
      End;                        {case}
    End;                          {leftargument}


    Function valid_selection : Integer;

      { determines whether mouse arrow is over a valid field}

    Var valid      : Boolean;
      dp             : dialogentryp;
      lineno, i, bottomargument : Integer;

    Begin                         {valid_selection}
      valid := False;
      dp := dialog;
      If (mousey > (getmaxy-boxheight) Div 2) And
      (mousey < (getmaxy+boxheight) Div 2) Then
      Begin
        lineno := (mousey-(getmaxy-boxheight) Div 2+textheight(' '))
        Div (textheight(' ')*2);
        bottomargument := (getmaxy-boxheight) Div 2
                          +textheight(' ')*(2*narguments+1);
        If Not(lineno In [1..narguments]) Then
          valid := (lineno = narguments+2) And continueprompt And
          (mousex > leftedge+textwidth('  ')) And
          (mousex < leftedge+textwidth('   Continue '))
        Else
        Begin
          dp := dialog;           {find relevant dialog entry}
          For i := 2 To lineno Do
            dp := dp^.next;
          Case dp^.argtype Of
            _boolean : valid := (mousex > leftargument(dp)) And
                       (mousex < leftargument(dp)+textwidth('      '));
            _char, _integer, _real, _string : valid :=
                                              (mousex > leftargument(dp)) And
                                              (mousex < rightedge);
          End;                    {case}
        End;
      End;
      If valid Then
        valid_selection := lineno
      Else
        valid_selection := -1;
    End;                          {valid_selection}


    Procedure display_argument(dp : dialogentryp);

      { displays dialog argument right justified}

    Var str1       : String;

    Begin                         {display_argument}
      Case dp^.argtype Of
        _boolean : Begin
                     If dp^.booleanresult Then
                       str1 := ' Y  n'
                     Else
                       str1 := ' y  N';
                     outtextxy(leftargument(dp), yposition, str1);
                     rectangle(leftargument(dp), yposition-textheight(' ')+1,
                               leftargument(dp)+textwidth('   '),
                               yposition+textheight(' '));
                     rectangle(leftargument(dp)+textwidth('   '),
                               yposition-textheight(' ')+1,
                               leftargument(dp)+textwidth('      '),
                               yposition+textheight(' '));
                   End;
        _char : outtextxy(leftargument(dp), yposition,
                          Copy(bigemptystring, 1,
                               charfieldlength-Length(dp^.charresult))
                          +dp^.charresult);
        _integer : Begin
                     Str(dp^.integerresult, str1);
                     outtextxy(leftargument(dp), yposition,
                               Copy(bigemptystring, 1,
                                    integerfieldlength-Length(str1))
                               +str1);
                   End;
        _real : Begin
                  Str(dp^.realresult:0:dp^.decimalp, str1);
                  outtextxy(leftargument(dp), yposition,
                            Copy(bigemptystring, 1,
                                 realfieldlength-Length(str1))
                            +str1);
                End;
        _string : outtextxy(leftargument(dp), yposition,
                            Copy(bigemptystring, 1,
                                 dp^.ssize-Length(dp^.stringresult))
                            +dp^.stringresult);
      End;                        {case}
    End;                          {display_argument}


    Procedure clear_argument(dp : dialogentryp);

      { erases argument box for dp}

    Begin                         {clear_argument}
      Case dp^.argtype Of
        _boolean : bar(leftargument(dp), yposition-textheight(' ')+2,
                       leftargument(dp)
                       +textwidth(Copy(bigemptystring, 1, booleanfieldlength)),
                       yposition+textheight(' ')-1);
        _integer : bar(leftargument(dp), yposition-textheight(' ')+2,
                       leftargument(dp)
                       +textwidth(Copy(bigemptystring, 1, integerfieldlength)),
                       yposition+textheight(' ')-1);
        _char : bar(leftargument(dp), yposition-textheight(' ')+2,
                    leftargument(dp)
                    +textwidth(Copy(bigemptystring, 1, charfieldlength)),
                    yposition+textheight(' ')-1);
        _real : bar(leftargument(dp), yposition-textheight(' ')+2,
                    leftargument(dp)
                    +textwidth(Copy(bigemptystring, 1, realfieldlength)),
                    yposition+textheight(' ')-1);
        _string : bar(leftargument(dp), yposition-textheight(' ')+2,
                      leftargument(dp)
                      +textwidth(Copy(bigemptystring, 1, dp^.ssize)),
                      yposition+textheight(' ')-1);
      End;                        {case}
    End;                          {clear_argument}


    Procedure underline(dp : dialogentryp; show : Boolean);

{ places underline below argument field ready for user input. show indicates
  whether line should be drawn or erased}

    Begin                         {underline}
      If show Then
        selectcolor(color)
      Else
        selectbcolor(bcolor);
      Case dp^.argtype Of
        _integer : line(leftargument(dp), yposition+textheight(' '),
                        leftargument(dp)+
                        textwidth(Copy(bigemptystring, 1, integerfieldlength)),
                        yposition+textheight(' '));
        _char : line(leftargument(dp), yposition+textheight(' '),
                     leftargument(dp)
                     +textwidth(Copy(bigemptystring, 1, charfieldlength)),
                     yposition+textheight(' '));
        _real : line(leftargument(dp), yposition+textheight(' '),
                     leftargument(dp)
                     +textwidth(Copy(bigemptystring, 1, realfieldlength)),
                     yposition+textheight(' '));
        _string : line(leftargument(dp), yposition+textheight(' '),
                       leftargument(dp)
                       +textwidth(Copy(bigemptystring, 1, dp^.ssize)),
                       yposition+textheight(' '));
      End;                        {case}
      selectcolor(color);
    End;                          {underline}


  Begin                           {dialog_box}
    mousearrowoff;
    settextjustify(lefttext, centertext);
    selectcolor(color);
    selectbfillstyle(solidfill, bcolor);
    maxstringlength := 0;
    dp := dialog;
    narguments := 0;
    While dp <> Nil Do            {find longest line}
    Begin
      Inc(narguments);
      Case dp^.argtype Of
        _none : i := 0;
        _boolean : i := booleanfieldlength+2;
        _char : i := charfieldlength+2;
        _integer : i := integerfieldlength+2;
        _real : i := realfieldlength+2;
        _string : i := dp^.ssize+2;
      End;                        {case}
      If i+Length(dp^.title) > maxstringlength Then
        maxstringlength := i+Length(dp^.title);
      dp := dp^.next;
    End;
    boxwidth := textwidth(Copy(bigemptystring, 1, maxstringlength+2));
    boxheight := (narguments*2+2+4*Ord(continueprompt))*textheight(' ');
    leftedge := (getmaxx-boxwidth) Div 2+textwidth(' ');
    rightedge := (getmaxx+boxwidth) Div 2-textwidth(' ');
    GetMem(savep,
           imagesize((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
                     (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2));
    getimage((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
             (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2,
             savep^);             {save image}
    bar((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
        (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2);
    rectangle((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
              (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2);
    dp := dialog;
    For i := 1 To narguments+Ord(continueprompt) Do
    Begin
      yposition := (getmaxy-boxheight) Div 2+textheight(' ')*i*2;
      If i > narguments Then
      Begin
        outtextxy(leftedge, yposition+textheight(' ')*2,
                  '   Continue');
        rectangle(leftedge+textwidth('  '), yposition+textheight(' '),
                  leftedge+textwidth('   Continue '),
                  yposition+textheight(' ')*3);
      End
      Else
      Begin
        outtextxy(leftedge, yposition, dp^.title);
        display_argument(dp);
      End;
      dp := dp^.next;
    End;
    Repeat
      i := 1;
      If (narguments > 1) Or (dialog^.argtype = _boolean)
        Or continueprompt Then
      Begin
        mousearrowon;
        Repeat
          Repeat
            c := trackmouse;
          Until (mousekeys > 0) Or (c In [^c, ^m]);
          If mousekeys = 1 Then
            i := valid_selection
          Else
            i := 0;
        Until (c In [^c, ^m]) Or (i > -1);
        mousearrowoff;
      End;
      If (i In [1..narguments]) And (c <> ^c) And Not((c = ^m)
           And (narguments > 1)) Then
      Begin
        yposition := (getmaxy-boxheight) Div 2+textheight(' ')*i*2;
        dp := dialog;
        For i := 2 To i Do
          dp := dp^.next;
        Case dp^.argtype Of
          _boolean : Begin
                       dp^.booleanresult := (c = ^m) Or
                       (mousex < leftargument(dp)+textwidth('   '));
                       clear_argument(dp);
                       display_argument(dp);
                     End;
          _integer, _real, _string :
            Begin
              Repeat Until keypressed Or (narguments > 1) Or (mousekeys > 1);
              If mousekeys < 2 Then
              Begin
                clear_argument(dp);
                underline(dp, True);
                moveto(leftargument(dp), yposition);
                Case dp^.argtype Of
                  _integer : greadinteger(dp^.integerresult);
                  _real : greadreal(dp^.realresult);
                  _string : Begin
                              str1 := dp^.stringresult;
                              greadstring(dp^.stringresult, dp^.ssize);
                              If Not dp^.nulvalid And
                              (Length(dp^.stringresult) = 0) Then
                                dp^.stringresult := str1;
                            End;
                End;              {case}
                underline(dp, False);
                clear_argument(dp);
                display_argument(dp);
              End;
            End;
          _char : Begin
                    Repeat
                    Until keypressed Or (narguments > 1) Or (mousekeys > 1);
                    If mousekeys < 2 Then
                    Begin
                      clear_argument(dp);
                      underline(dp, True);
                      cl := readkey;
                      If cl <> ^m Then
                      Begin
                        outtextxy(leftargument(dp), yposition, cl);
                        dp^.charresult := cl;
                      End;
                      underline(dp, False);
                    End;
                  End;
        End;                      {case}
      End;

    Until ((narguments = 1) And Not(continueprompt)) Or (i > narguments)
    Or (continueprompt And (c = ^m)) Or (i = 0);
    putimage((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2, savep^,
             normalput);
    FreeMem(savep,
            imagesize((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
                      (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2));
    mousearrowon;
  End;                            {dialog_box}


  Procedure dispose_dialog(Var dp : dialogentryp);

    { disposes of all entries in dialog list}

  Var d          : dialogentryp;

  Begin                           {dispose_dialog}
    d := dp;
    While d <> Nil Do
    Begin
      d := d^.next;
      Dispose(dp);
      dp := d;
    End;
  End;                            {dispose_dialog}


  Procedure fill_background(color, fillpattern, arcsize : Word);

    { fills background with color and rounds the corners}

  Var xasp, yasp : Word;
    aspect         : Real;

  Begin
    cleardevice;
    selectcolor(color);
    getaspectratio(xasp, yasp);
    aspect := 1.0*xasp/yasp;
    selectfillstyle(fillpattern, color);
    setlinestyle(userbitln, 0, normwidth); {no outline}
    bar(0, 0, getmaxx, getmaxy);

    selectfillstyle(solidfill, black);
    bar(0, 0, Pred(arcsize), Pred(Round(arcsize*aspect)));
    selectfillstyle(fillpattern, color);
    pieslice(arcsize, Round(arcsize*aspect), 90, 180, arcsize);

    selectfillstyle(solidfill, black);
    bar(Succ(getmaxx-arcsize), 0, getmaxx, Pred(Round(arcsize*aspect)));
    selectfillstyle(fillpattern, color);
    pieslice(getmaxx-arcsize, Round(arcsize*aspect), 0, 90, arcsize);

    selectfillstyle(solidfill, black);
    bar(0, getmaxy, Pred(arcsize), Succ(getmaxy-Round(arcsize*aspect)));
    selectfillstyle(fillpattern, color);
    pieslice(arcsize, getmaxy-Round(arcsize*aspect), 180, 270, arcsize);

    selectfillstyle(solidfill, black);
    bar(Succ(getmaxx-arcsize), getmaxy, getmaxx,
        Succ(getmaxy-Round(arcsize*aspect)));
    selectfillstyle(fillpattern, color);
    pieslice(getmaxx-arcsize, getmaxy-Round(arcsize*aspect), 270,
             360, arcsize);
    selectcolor(black);
    setlinestyle(solidln, 0, normwidth);
  End;                            {fill_background}


  Procedure panel(x, y : Integer; width, height, color : Word);

    { draws solid panel with center top at x,y, width by height}

  Var currentcolor : Word;

  Begin
    currentcolor := getcolor;
    selectcolor(color);
    selectfillstyle(solidfill, color);
    bar(x-width Div 2, y, x+width Div 2, y+height);
    selectcolor(currentcolor);
  End;                            {panel}


  Procedure add_clickboxentry(Var cp, lastclickbox,
                              clickboxhead : clickboxtypep);

    { appends clickbox to list}

  Begin                           {add_clickboxentry}
    cp^.next := Nil;
    If clickboxhead = Nil Then
      clickboxhead := cp
    Else
      lastclickbox^.next := cp;
    lastclickbox := cp;
  End;                            {add_clickboxentry}


  Function box_width(cp : clickboxtypep) : Integer;

    { calculates width of click box}

  Var i, boxwidth : Integer;
    p              : polypointp;
    pi             : LongInt Absolute p;

  Begin                           {boxwidth}
    Case cp^.ttype Of
      _text : box_width := textwidth(cp^.title+'  ');
      _figure : Begin
                  boxwidth := 0;
                  p := cp^.polypoints;
                  For i := 1 To cp^.numpoints Do
                  Begin
                    If p^.x > boxwidth Then
                      boxwidth := p^.x;
                    pi := pi+4;
                  End;
                  box_width := textwidth(' ')
                               *(Succ(boxwidth) Div textwidth(' ')+2);
                End;
    End;                          {case}
  End;                            {box_width}


  Procedure draw_clicklist(cp : clickboxtypep; x, y, bcolor, color : Integer);

    { draws list of click boxes}


    Procedure draw_clickbox(cp : clickboxtypep; x, y : Integer);

      { draws one click box}

    Var boxwidth, boxheight : Integer;
      viewport       : viewporttype;

    Begin                         {draw_clickbox}
      settextjustify(lefttext, centertext);
      boxwidth := box_width(cp);
      boxheight := textheight(' ')*2;
      selectbfillstyle(solidfill, bcolor);
      bar(x+cp^.x, y+cp^.y, x+cp^.x+boxwidth, y+cp^.y+boxheight);
      rectangle(x+cp^.x, y+cp^.y, x+cp^.x+boxwidth, y+cp^.y+boxheight);
      selectfillstyle(solidfill, color);
      Case cp^.ttype Of
        _text : outtextxy(x+cp^.x, y+cp^.y+textheight(' '), ' '+cp^.title);
        _figure : Begin
                    getviewsettings(viewport);
                    setviewport(cp^.x+x+textwidth(' '), cp^.y+y,
                                cp^.x+x+boxwidth, cp^.y+y+boxheight, True);
                    drawpoly(cp^.numpoints, cp^.polypoints^);
                    If cp^.fill Then
                      fillpoly(cp^.numpoints, cp^.polypoints^);
                    setviewport(viewport.x1, viewport.y1,
                                viewport.x2, viewport.y2, viewport.clip);
                  End;
      End;                        {case}
    End;                          {draw_clickbox}


  Begin                           {draw_clicklist}
    selectcolor(color);
    While cp <> Nil Do
    Begin
      draw_clickbox(cp, x, y);
      cp := cp^.next;
    End;
  End;                            {draw_clicklist}


  Function click_selection(cp : clickboxtypep; x, y : Integer) : Integer;

    { tests whether mouse is over a click box and returns its number in
      the list}

  Var boxno      : Integer;
    found          : Boolean;

  Begin                           {click_selection}
    found := False;
    boxno := 0;
    While Not found And (cp <> Nil) Do
    Begin
      found := (mousex >= x+cp^.x) And (mousex <= x+cp^.x+box_width(cp)) And
        (mousey >= y+cp^.y) And (mousey <= cp^.y+y+textheight(' ')*2);
      Inc(boxno);
      If Not found Then
        cp := cp^.next;
    End;
    If cp <> Nil Then
      click_selection := boxno
    Else
      click_selection := -1;
  End;                            {click_selection}


  Procedure dispose_clickboxlist(Var cp : clickboxtypep);

    { disposes of all entries in click box list}

  Var c          : clickboxtypep;

  Begin                           {dispose_clickboxlist}
    c := cp;
    While c <> Nil Do
    Begin
      c := c^.next;
      Dispose(cp);
      cp := c;
    End;
  End;                            {dispose_clickboxlist}


  Procedure display_message(s : String; bcolor, color : Integer;
                            Var storagep : Pointer;
                            show           : Boolean);

{ draws message in box at screen center (or restores screen if show=false).
 a storage pointer must be supplied to allow reentrance}

  Var boxwidth, boxheight : Integer;

  Begin                           {display_message}
    settextjustify(lefttext, centertext);
    boxwidth := textwidth(s+'  ');
    boxheight := textheight(' ')*2;
    If show Then
    Begin
      selectcolor(color);
      selectbfillstyle(solidfill, bcolor);
      GetMem(storagep,
             imagesize((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
                       (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2));
      getimage((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
               (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2, storagep^);
      bar((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
          (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2);
      rectangle((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
                (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2);
      outtextxy((getmaxx-boxwidth) Div 2, getmaxy Div 2, ' '+s);
    End
    Else
    Begin
      putimage((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2, storagep^,
               normalput);
      FreeMem(storagep,
              imagesize((getmaxx-boxwidth) Div 2, (getmaxy-boxheight) Div 2,
                        (getmaxx+boxwidth) Div 2, (getmaxy+boxheight) Div 2));
    End;
  End;                            {display_message}


  Function continue_prompt(x, y, bcolor, color : Integer) : Char;

    { displays continue prompt and waits for button or key}

  Var cp         : clickboxtypep;
    c              : Char;
    j              : Integer;

  Begin                           {continue_prompt}
    c := '.';
    settextstyle(defaultfont, horizdir, 1);
    New(cp);
    With cp^ Do
    Begin
      ttype := _text;
      title := 'Continue';
      x := 0;
      y := 0;
      next := Nil;
    End;
    If x < 0 Then
      x := getmaxx+x-textwidth(cp^.title+'  ');
    If y < 0 Then
      y := getmaxy+y-textheight(' ')*2;
    draw_clicklist(cp, x, y, bcolor, color);
    j := -1;
    mousearrowon;
    Repeat
      Repeat
        c := trackmouse;
      Until (mousekeys > 0) Or (c In [^c, ^m]);
      If mousekeys > 1 Then
        j := 0
      Else
        If mousekeys = 1 Then
          j := click_selection(cp, x, y);
    Until (j > -1) Or (c In [^c, ^m]);
    dispose_clickboxlist(cp);
    continue_prompt := c;
  End;                            {continue_prompt}


Begin                             {initialisation}
  exitsave := ExitProc;           {install myerror}
  ExitProc := @myexit;
  showerrormessage := True;
  For i := 1 To screens Do
  Begin
    firstget[i] := True;
    firstput[i] := True;
  End;
  currentscreen := 1;
End.